home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / ilbm_maker < prev    next >
Encoding:
Text File  |  1992-01-26  |  4.6 KB  |  196 lines
  1. \ Tools to create an ILBM FORM from a bitmap.
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1987 Phil Burk
  5. \
  6. \ MOD: 3/10/91 by Martin Kees
  7. \      uses faster packing routines in modified jiff:packing
  8. \ MOD: PLB/MK 7/9/91 c/iff.write?/fwrite/ for proper even-up
  9. \      of odd sized chunks
  10. \ 00001 PLB 11/14/91 Improve error handling, check FWRITEs
  11. \ 00002 PLB 12/3/91 Use FORMPOS variable for proper error handling.
  12. \ 00003 PLB 1/26/92 Changed ILBM.WRITE.BITMAP to ILBM.WRITE.BITMAP?
  13. \           because of ERROR? return.  ILBM.WRITE.BITMAP aborts on error.
  14.  
  15. include? AllocRaster() ju:graph_support
  16. include? { ju:locals
  17. include? vpackrow jiff:packing
  18. include? task-iff_support jiff:iff_support
  19. decimal
  20. ANEW TASK-ILBM_MAKER
  21.  
  22. \ -----------------------------------------
  23. : ILBM.HEADER.SETUP  { bmap bmapheader -- , set w,h and depth }
  24.     bmapheader sizeof() Bitmapheader erase
  25.     bmap ..@ bm_depth bmapheader ..! bmh_nplanes
  26.     bmap bitmap>wh 2dup
  27.     bmapheader ..! bmh_h bmapheader ..! bmh_w
  28.     200 max bmapheader ..! bmh_pageheight
  29.     320 max bmapheader ..! bmh_pagewidth
  30.     1 bmapheader ..! bmh_xaspect
  31.     1 bmapheader ..! bmh_yaspect
  32.     cmpByteRun1 bmapheader ..! bmh_compression
  33.     2 bmapheader ..! bmh_masking
  34. ;
  35.  
  36.  
  37. \ Writing an IFF File
  38. \ 1) Open file
  39. \ 2) Start ILBM form
  40. \ 3) Write BMHD
  41. \ 4) Write CMAP
  42. \ 5) Write BODY
  43. \ 6) Write optional chunks, GRAB, CRNG
  44. \ 7) End FORM
  45. \ 2) Close File
  46.  
  47. \ Declare a scratch header if not already present.
  48. .need ILBM-Header
  49. BitMapHeader ILBM-Header
  50. .THEN
  51.  
  52. \ This is an example of how to write an interleaved bitmap
  53. \ Using the ILBM tools.  You will probably need to
  54. \ write a customized version.
  55. \ Write BitMapHeader
  56. : ILBM.WRITE.HEADER? ( bitmap -- error? , write header based on bitmap )
  57.     ilbm-header ilbm.header.setup
  58.     ilbm-header sizeof() BitMapheader 'BMHD' iff.write.chunk?
  59. ;
  60.  
  61. \ MODIFIED to use WRITE.BITMAP.BODY for packing speed increase
  62. \ and avoidance of memory problems ( only needs 2K buffer )
  63. : ILBM.WRITE.BODY? { bmap | bodyptr bsize -- error? }
  64. \
  65. \ write BODY chunk ID
  66.     iff.where -> bodyptr
  67.     0 'BODY' iff.write.chkid? ?goto.error
  68. \
  69. \ write body data
  70.     bmap iff-fileid @ ilbm-header ..@ bmh_compression
  71.     write.bitmap.body dup -> bsize 0= ?goto.error
  72. \
  73. \ write correct chunk-size
  74.     iff.where
  75.     bodyptr cell+ iff.seek
  76.     bsize pad ! pad 4 iff.write?
  77.     swap iff.seek
  78.     ?goto.error
  79. \
  80. \ even-up iff chunk
  81.     bsize 1 and
  82.     IF
  83.         iff-fileid @ pad 1 fwrite 1 - ?goto.error
  84.     THEN
  85.     false
  86.     exit
  87. ERROR:
  88.     ." ILBM.WRITE.BODY? failed!" cr
  89.     true
  90. ;
  91.  
  92. : ILBM.WRITE.BITMAP?  ( bitmap -- error? , write as BODY to ILBM )
  93.     dup ilbm.write.header? 0=
  94.     IF
  95.         ilbm.write.body?
  96.     ELSE
  97.         drop TRUE
  98.     THEN
  99. ;
  100.  
  101. : ILBM.WRITE.BITMAP  ( bitmap -- , OBSOLETE , just abort if error )
  102.     ilbm.write.bitmap?
  103.     IF
  104.         " ILBM.WRITE.BITMAP failed!" $error
  105.     THEN
  106. ;
  107.  
  108.  
  109. \ Note the order of chunks here.  Some applications, eg.
  110. \ Art Departmnent require the property chunks (CMAP, etc.) to be
  111. \ between the Header chunk and the BODY chunk!
  112. : ILBM.WRITE.ILBM?  { bmap ctable ctable# | formpos -- error? , write bitmap in ILBM file}
  113.     iff-fileid @ 0=
  114.     IF ." You must open an IFF file first using $IFF.OPEN" cr
  115.         goto.error
  116.     THEN
  117.     'ilbm' iff.begin.form? ?goto.error  ( -- formpos )
  118.     -> formpos \ 00002
  119. \
  120. \ Write Bitmap Header
  121.     bmap ilbm.write.header? ?goto.error
  122. \
  123. \ Generate CMAP and write it.
  124.     ctable
  125.     IF  ctable pad ctable# ctable>cmap  ( use pad to pack cmap )
  126.         pad ctable# 3 * 'CMAP' iff.write.chunk? ?goto.error
  127.     THEN
  128. \
  129. \ Write Bitmap
  130.     bmap ilbm.write.body? goto.error
  131. \
  132. \ Close out 'FORM'
  133.     formpos iff.end.form? ?goto.error \ 00002
  134. \
  135.     false
  136.     exit
  137.  
  138. ERROR:
  139.     true
  140. ;
  141.  
  142. : ILBM.WRITE.ILBM+CAMG?  { bmap ctable ctable# camg | formpos -- error? }
  143. \ This word is needed if writing a screen of data.
  144.     iff-fileid @ 0=
  145.     IF ." You must open an IFF file first using $IFF.OPEN" cr
  146.         goto.error
  147.     THEN
  148.     'ilbm' iff.begin.form? ?goto.error  ( -- formpos )
  149.     -> formpos \ 00002
  150. \
  151. \ Write Bitmap Header
  152.     bmap ilbm.write.header? ?goto.error
  153. \
  154. \ Write CAMG value.
  155.     camg pad !
  156.     pad 4 'CAMG' iff.write.chunk? ?goto.error
  157. \
  158. \ Generate CMAP and write it.
  159.     ctable
  160.     IF  ctable pad ctable# ctable>cmap  ( use pad to pack cmap )
  161.         pad ctable# 3 * 'CMAP' iff.write.chunk? ?goto.error
  162.     THEN
  163. \
  164. \ Write Bitmap
  165.     bmap ilbm.write.body? ?goto.error
  166. \
  167. \ Close out 'FORM'
  168.     formpos iff.end.form? ?goto.error \ 00002
  169. \
  170.     false
  171.     exit
  172. \
  173. ERROR:
  174.     true
  175. ;
  176.  
  177. : $SCREEN>IFF? { scrn $filename | vp -- error? , write screen to IFF file }
  178.     $filename new $iff.open?
  179.     IF
  180.         scrn .. sc_bitmap
  181.         scrn .. sc_viewport -> vp ( -- bm vp )
  182.         vp ..@ vp_colormap >rel
  183.         dup ..@ cm_ColorTable >rel
  184.         swap ..@ cm_count
  185.         vp ..@ vp_modes  ( get CAMG )
  186.         ilbm.write.ilbm+camg?
  187.         iff.close
  188.     ELSE
  189.         TRUE
  190.     THEN
  191. ;
  192.  
  193. : SCREEN>IFF? ( screen <filename> -- error? , write screen IFF file )
  194.     fileword $screen>iff?
  195. ;
  196.